{ pasmat -q -k -t 2 -: aFKEY6.p FKEY6.p -r -u }

{ These are the pascal procedures used with  FKEY6        }

{ The main objective of this sample is to show in a different setting
  how to spool a large picture directly to disk.      }

{ The way this goal is achieved is by replacing the standard putPicProc
  with our own, which writes all data sent to it directly to a disk file.
  Using this method the memory hit is reduced to a minimun.    }

{ The basic strategy is as follows:
  1.- Make sure we can create the file.
  2.- If Color QuickDraw is available then use a color port
      else use a regular B/W port
  3.- Replace the bottleneck procedure for our own putPict procedure
  4.- Open a picture, 3 above guarantees that data will go to disk
  5.- CopyBits the whole screen into itself causing the stuff to go
      to the picture.
  6.- Close the picture
  7.- Finish the PICT file.
  8.- Leave things (QDProcs, port) the way they were.       }

{ Another point of interest is the technique used to provide pseudo
  globals needed for the process to work by tagging the fields to the
  end of the grafport record.           }

UNIT FKEY;
  { September 27, 1988    v1.0         }

  INTERFACE

    USES Memtypes, Quickdraw, OSIntf, ToolIntf, PackIntf;

    TYPE
      BitMapPtr = ^BitMap; { Type casting stuff }

{ structure used to mantain some globals that can not be accessed
  in the standard way when QD calls the bottleneck procedure   }

    TYPE
      GDataRec = RECORD
                   pHand: PicHandle; { picture being created }
                   gRef: INTEGER; { file reference number }
                   fileOK: BOOLEAN; { problems flag }
                 END;

      { now lets put together a port + our data structure      }
      GportPlus = RECORD
                    TRUEPort: CGrafPort;
                    GDStuff: GDataRec;
                  END;
      GPPtr = ^GportPlus;

    PROCEDURE PICTOut;
    { main procedure for the FKEY }

    PROCEDURE PutPICTData(dataPtr: Ptr;
                          byteCount: INTEGER);
    { PutPICTData replaces the standard bottleneck proc }

  IMPLEMENTATION

    PROCEDURE PutPICTData{(dataPtr: Ptr; byteCount: INTEGER)};

      VAR
        longCount: LONGINT; { byte count }
        myPortPlus: GPPtr; { global data pointer }

      BEGIN

        GetPort(grafPtr(myPortPlus)); { to access the global data }

        longCount := byteCount;

        IF myPortPlus^.GDStuff.fileOK THEN { do this only if file is still OK }
          BEGIN
            IF FSWrite(myPortPlus^.GDStuff.gRef, longCount, dataPtr) <>
               noErr THEN
              myPortPlus^.GDStuff.fileOK := FALSE;
            { something bad occurred, must delete file }

            IF myPortPlus^.GDStuff.pHand <> NIL THEN { if the picture is already
                                                      open }
              myPortPlus^.GDStuff.pHand^^.picSize := myPortPlus^.GDStuff.pHand^^
                                                     .picSize + longCount;
            { keep size up to date so QD }
            { can adjust for oddness        }
          END

      END;

{ The main procedure of the FKEY.
  This code installs the bottle neck procedure, opens the picture and does all
  the house keeping.
}

    PROCEDURE PICTOut;

      VAR
        err: OSErr;
        i: INTEGER;
        longCount, longZero: LONGINT;
        myProcs: CQDProcs;
        myOldProcs: QDProcs;

        savePictSizeFrame: Picture;

        nameStr: Str255;
        vrefnum: INTEGER;
        bytesAvail: LONGINT;

        oldPort: grafPtr;
        wPortPlus: GportPlus;
        wPortPlusPtr: GPPtr;
        myDev: GDHandle;
        pictHand: PicHandle;
        globalRef: INTEGER;

        theWorld: SysEnvRec;

        bitPtr: BitMapPtr;

      PROCEDURE DeathKiss;

{ We use this procedure to kill the file if something fails.
  We don't want to leave files laying around, do we? }

        BEGIN

          IF globalRef <> 0 THEN err := FSClose(globalRef);
          { close the file if it is open }
          err := FSDelete(nameStr, vrefnum); { to make sure Delete works }
          SysBeep(1); { Let the world know }
          Exit(PICTOut); { and get out of here! }
        END {DeathKiss} ;

      BEGIN {PICTOut}

        err := SysEnvirons(1, theWorld); { Lets check if we have what we need }

        { initializing the pointer to port + global stuff}
        wPortPlusPtr := @wPortPlus;

{ Init this variable to help exit procedure clean our stuff
  when we have to run away.
}
        globalRef := 0; { if not zero then a file is open }

        { first we see if it is possible to open file }

        IF GetVInfo(0, @nameStr, vrefnum, bytesAvail) <> noErr THEN
        { get info on default volume }
          DeathKiss; { error, get out of here! }

{ At this point we could check to see if there is room in the volume for the PICT file,
  I chose not to because using a value for the maximun length could probably abort the
  process when there is room for the actual length. I decided that it is better to fail
  when trying to write than kill the saving without reason. }

{ We try to create a file 'Screen x' beginning with 0 up to 9, if ten
  files exist we exit and abort the saving              }
        nameStr := 'Screen 0'; { initial name }
        REPEAT
          BEGIN
            err := Create(nameStr, vrefnum, 'GAO.', 'PICT');
            IF err <> noErr THEN
              BEGIN
                IF err = dupFNErr THEN { if file already }
                  BEGIN {there bump the name }
                    nameStr[8] := Chr(Ord(nameStr[8]) + 1);
                    IF nameStr[8] = ':' THEN { ten files should be enough }
                      DeathKiss; { can't make more files, get out of here! }
                  END
                ELSE
                  DeathKiss; { error, get out of here! }
              END
          END
        UNTIL (err = noErr);

        IF FSOpen(nameStr, vrefnum, globalRef) <> 0 THEN { if error delete }
          DeathKiss; { error, get out of here! }

    { file should be open at this point, so we try to write out the
      header for the pict file }
        longZero := 0;
        longCount := 4;
        FOR i := 1 TO (512 + SizeOf(Picture)) DIV 4 DO { init PICT header }
          BEGIN
            err := FSWrite(globalRef, longCount, @longZero);
            IF err <> noErr THEN
              DeathKiss {error while file open, get out and kill file }
          END;

        GetPort(oldPort); { save current port }

        { init global vars }
        wPortPlus.GDStuff.gRef := globalRef; { for file accesses }
        wPortPlus.GDStuff.pHand := NIL; { no picture when begining }
        wPortPlus.GDStuff.fileOK := TRUE; { we hope }

        IF theWorld.hasColorQD THEN
          BEGIN
            OpenCport(CGrafPtr(wPortPlusPtr)); { Lets get a color port }
            SetStdCProcs(myProcs); { set its bottleneck procs }
            grafPtr(wPortPlusPtr)^.grafProcs := @myProcs;
            myProcs.putPicProc := @PutPICTData;
            myDev := GetMainDevice; { to get to screen }
            bitPtr := BitMapPtr(myDev^^.gdPMap^)
          END
        ELSE
          BEGIN
            Openport(grafPtr(wPortPlusPtr)); { Lets get an old style port }
            SetStdProcs(myOldProcs); { set procs }
            grafPtr(wPortPlusPtr)^.grafProcs := @myOldProcs;
            myOldProcs.putPicProc := @PutPICTData;
            bitPtr := BitMapPtr(@wPortPlusPtr^.TRUEPort.portPixMap)
            { old stuff}
          END;

        ClipRect(bitPtr^.bounds); { Just in case, make sure clip region is OK. }

        pictHand := OpenPicture(bitPtr^.bounds);

    { On a Macintosh II + color port OpenPicture fails if the heap 
			doesn't have at least 1000 bytes free, so we better check 
			if we have a valid handle         }

        IF pictHand <> NIL THEN
          BEGIN
            wPortPlus.GDStuff.pHand := pictHand; { now we have a handle }

            CopyBits(bitPtr^, { CopyBits will call our procedure }
                     bitPtr^, bitPtr^.bounds, bitPtr^.bounds, srcCopy, NIL);

            ClosePicture;

            savePictSizeFrame := pictHand^^; 
						{ We need this later to complete file }
            
						KillPicture(pictHand) { release all memory }
          END
        ELSE { no picture saved so we have to kill the file }
          wPortPlus.GDStuff.fileOK := FALSE;

        { Now we proceed to clean up and to restore the port }
        grafPtr(wPortPlusPtr)^.grafProcs := NIL;
        SetPort(oldPort);
        IF theWorld.hasColorQD THEN
          CloseCport(CGrafPtr(wPortPlusPtr))
          { Lets get rid of the color port }
        ELSE
          ClosePort(grafPtr(wPortPlusPtr)); {or get rid of the normal port}

{ after everything is back in good shape we can check if the copybits data
  went to disk a O.K. and if there is a picture at all }

        IF NOT (wPortPlus.GDStuff.fileOK) THEN DeathKiss; {error while saving
                                                           file, exit }

        IF SetFPos(globalRef, fsFromStart, 512) <> noErr THEN DeathKiss; {error
          while positioning file, exit }

        longCount := SizeOf(Picture);
        IF FSWrite(globalRef, longCount, @savePictSizeFrame) <> noErr THEN
          DeathKiss; {error while writing picture size and rect to file, exit }

        IF FSClose(globalRef) <> noErr THEN { now close the file }
          DeathKiss; {error while closing file, exit }

      END; {PICTOut}

END. { Unit FKEY }
